home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 February: Tool Chest / Apple Developer CD Series Tool Chest February 1996 (Apple Computer)(1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / zebu v3.3.3 (LALR parser) / zebu-loadgram.lisp < prev    next >
Encoding:
Text File  |  1994-09-12  |  26.8 KB  |  764 lines  |  [TEXT/ttxt]
  1. ; -*- mode:     CL -*- ----------------------------------------------------- ;
  2. ; File:         zebu-loadgram.l
  3. ; Description:  Load a grammar file (type: .zb) so that it can be compiled
  4. ; Author:       Joachim H. Laubsch
  5. ; Created:      10-Oct-90
  6. ; Modified:     Tue Jul 26 17:10:11 1994 (Joachim H. Laubsch)
  7. ; Language:     CL
  8. ; Package:      ZEBU
  9. ; Status:       Experimental (Do Not Distribute) 
  10. ; RCS $Header: $
  11. ;
  12. ; (c) Copyright 1990, Hewlett-Packard Company
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ; Revisions:
  15. ; RCS $Log: $
  16. ; 26-Jul-94 (Joachim H. Laubsch)
  17. ;  Fixed Bug with "." as separator (ambiguous constituent names were made)
  18. ; 12-Mar-93 (Joachim H. Laubsch)
  19. ;  Bind a Kleene* Variable
  20. ;  9-Mar-93 (Joachim H. Laubsch)
  21. ;  allow a print-function specification in a domain definition rule
  22. ;  8-Feb-93 (Joachim H. Laubsch)
  23. ;  allow defstruct forms for domain definition among the rules
  24. ; 31-Jul-92 (Joachim H. Laubsch)
  25. ;  Introduced Kleene * and +
  26. ; 24-Apr-92 (Joachim H. Laubsch)
  27. ;  Introduced a meta-grammar for reading a user grammar
  28. ;  The meta-grammar is compiled using the null-grammar
  29. ; 25-Mar-92 (Joachim H. Laubsch)
  30. ;  Warn about unused non-terminals
  31. ; 16-Jul-91 (Joachim H. Laubsch)
  32. ;  to deal with multiple-grammars, first find in a grammar file: *GRAMMAR-OPTIONS*
  33. ;  a keyworded arglist that can be passed to MAKE-GRAMMAR
  34. ; 20-Mar-91 (Joachim H. Laubsch)
  35. ;  Introduced error checking during loading of grammar
  36. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37. ;;;             Copyright (C) 1989, by William M. Wells III
  38. ;;;                         All Rights Reserved
  39. ;;;     Permission is granted for unrestricted non-commercial use.
  40.  
  41. (IN-PACKAGE  "ZEBU")
  42. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  43. (defvar *Kleene+-rules* ()
  44.   "A list of rules that are generated as a consequence of the Kleene notation")
  45. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  46. ;;                     Read in a File Containing a Grammar
  47. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  48. ;;; RULES
  49. ;;; About the representations of grammars in files:
  50. ;;;      non terminals are represented by lisp symbols,
  51. ;;;      terminals by symbols (IDENTIFIER NUMBER STRING), or strings
  52. ;;; for example then BNF rule:
  53. ;;;         A ::= B | C | "foo" | "c" | <the-empty-string>
  54. ;;;
  55. ;;; would be encoded -- using the NULL Grammar -- as:
  56.  
  57. ;;; (defrule A := B
  58. ;;;            :build (f1 B)
  59. ;;;
  60. ;;;            := C
  61. ;;;            :build (f2 C)
  62. ;;;
  63. ;;;            := "foo"
  64. ;;;                                   ; ommitting the build clause has the
  65. ;;;            := "c"                 ; effect of calling the identity function
  66. ;;;            := () )
  67.  
  68. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  69. ;;                          Format for a grammar file
  70. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  71. #||
  72. A grammar file has a filename of type "zb".
  73.  
  74. The file consists of:
  75.  
  76. 1.  A keyword agument-list for MAKE-GRAMMAR.
  77.     Example:
  78.         (:name "pc2"
  79.          :package "CL-USER"
  80.      :grammar "zebu-mg"
  81.      :identifier-continue-chars
  82.      "$-_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890"
  83.      )
  84. 2.  If parsing with the NULL-Grammar
  85.      ( the default, if no :grammar keyword is given in 1.)
  86.      one or more defrule forms as above
  87.     If parsing with the META-Grammar
  88.      one or more rules using the syntax of the Meta-grammar
  89.      The start symbol of the grammar will be the lhs of the first
  90.      production encountered.  
  91.  
  92. The symbol AUGMENTED-START is reserved and will automatically appear in
  93. a production deriving the start symbol.
  94. The symbol THE-EMPTY-STRING is also reserved. 
  95.  
  96. Use load-grammar to internalize a grammar in the above syntax.
  97.  *productions* holds a list of all the productions.
  98.  *lambdas* holds a list of all of the associated lambdas (in reverse order)
  99.  *non-terminals* holds a list of all the non-terminals.
  100. Each non-terminal symbol has a list of the productions it
  101. appears in the left hand side of under its own-productions
  102. property.
  103. *g-symbol-alist* holds an alist whose cars are the string or symbol
  104.   which is read from the grammar, and whose cdrs hold corresponding
  105.   g-symbol structures; the order is in the reverse sense of *symbol-array*.
  106. ||#
  107.  
  108. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  109. ;;                              Global variables
  110. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  111.  
  112. (defvar *symbols*) ; a list of the grammar symbols
  113. (defvar *symbol-array*) ; indexed by the symbol's index, of g-symbols
  114. (defvar *productions*)
  115. (defvar *production-count*)
  116. (defvar *g-symbol-count*)
  117. (defvar *g-symbol-alist*)
  118. (defvar *start-symbol*)
  119. (defvar *empty-string-g-symbol*)
  120. (defvar *augmented-start-g-symbol*)
  121. (defvar *the-end-g-symbol*)
  122.  
  123. (defvar *grammar-options*)
  124.  
  125. (declaim (special
  126.           *identifier-continue-chars*
  127.           *identifier-start-chars*
  128.           *null-grammar*
  129.           *compiler-grammar* 
  130.           *domain-type-hierarchy*
  131.           *domain-types*
  132.           *domain-structs*
  133.           *lex-cats*))
  134.  
  135. ;; new rule format
  136. (defvar *ignore* '("DUMMY" "DUMMY1" "DUMMY2" "DUMMY3" "DUMMY4"
  137.            "DUMMY5" "DUMMY6" "DUMMY7" "DUMMY8"))
  138. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  139. ;;                                   macros
  140. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  141. (defmacro post-inc (x)
  142.   `(let ((old ,x))
  143.      (setq ,x (1+ ,x))
  144.      old))
  145.  
  146. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  147. ;;                               Initialisation
  148. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  149.  
  150. (defun initialize-grammar ()
  151.   (setq *symbols* '()
  152.     *productions* '()
  153.     *production-count* 0
  154.     *g-symbol-count* 0
  155.     *g-symbol-alist* '()
  156.     *start-symbol* '()
  157.     *zb-rules* '()
  158.     *lex-cats* '()
  159.     *domain-types* '()
  160.     *domain-structs* '()
  161.     *domain-type-hierarchy* '()
  162.     *empty-string-g-symbol* (g-symbol-intern 'the-empty-string)
  163.     *augmented-start-g-symbol* (g-symbol-intern 'augmented-start)
  164.     *the-end-g-symbol* (g-symbol-intern 'the-end-g-symbol))
  165.   )
  166.  
  167. ;----------------------------------------------------------------------------;
  168. ; g-symbol-intern
  169. ;----------------
  170. ; This is sort of like interning.  returns a g-symbol. 
  171. ; if (equal (string x) (string y)) the g-symbols are eq
  172.  
  173. (defun g-symbol-intern (string-or-symbol)
  174.   (check-type string-or-symbol (or string symbol)
  175.           "a string or symbol, in order to be a well-formed Zebu grammar rule.")
  176.   (let ((pair (assoc string-or-symbol *g-symbol-alist*
  177.              :test #'equal)))
  178.     (if pair
  179.     (cdr pair)
  180.       (let ((symbol (new-g-symbol
  181.              (string string-or-symbol)
  182.              (post-inc *g-symbol-count*))))
  183.     (push (cons string-or-symbol symbol) *g-symbol-alist*)
  184.     (push symbol *symbols*)
  185.     symbol))))
  186.  
  187. ;;; Do various things, fixing up global data structures and
  188. ;;; fields of grammar symbols.  A bit sleazy: *start-symbol* being NIL
  189. ;;; is used to detect the first production.
  190.  
  191. (defun process-production (lhs rhs &optional internal-use?)
  192.   (let ((lhs-symbol  (g-symbol-intern lhs))
  193.     ;; intern constituent as a G-SYMBOL
  194.     (rhs-symbols (mapcar #'g-symbol-intern rhs)))
  195.     (unless *start-symbol*
  196.       (setq *start-symbol* lhs-symbol)
  197.       (format t "~%Start symbols is: ~A~%" 
  198.           (g-symbol-name *start-symbol*))
  199.       (process-production 'AUGMENTED-START (list lhs) t))
  200.     (let ((production
  201.        (make-production :lhs lhs-symbol
  202.                 :rhs rhs-symbols
  203.                 :production-index (post-inc *production-count*)
  204.                 :production-length (length rhs-symbols))))
  205.       (when (and (eq lhs-symbol *augmented-start-g-symbol*)
  206.          (not internal-use?))
  207.     (error "AUGMENTED-START is a reserved grammar symbol"))
  208.       (push production *productions*)
  209.       (g-symbol-add-production lhs-symbol production)
  210.       (let ((rhs-symbol-set (make-oset :order-fn #'g-symbol-order-function)))
  211.     (dolist (gs rhs-symbols)
  212.       (oset-insert! gs rhs-symbol-set))
  213.     (dolist (gs (oset-item-list rhs-symbol-set))
  214.       (push production (g-symbol-rhs-productions gs)))))))
  215.  
  216. ;----------------------------------------------------------------------------;
  217. ; pre-process-rules
  218. ;------------------
  219. ; Given a function to produce the next rule, process it
  220. ; and warn about:
  221. ; - redefinition of lhs symbol
  222. ; - repeated equal rhs
  223. ; - unused lhs symbols
  224. ; - undefined non-terminals
  225. ; - duplicate constituents
  226.  
  227. (defun pre-process-rules (next-rule-fn do-semantics? &aux non-terminals)
  228.   (do ((zb-rule (funcall next-rule-fn) (funcall next-rule-fn)))
  229.       ((null zb-rule))
  230.     (let ((lhs (zb-rule--name zb-rule)))
  231.       (when (assoc lhs *zb-rules*)
  232.     (warn "Non-terminal ~S is defined again" lhs)
  233.     ;; (break "Rule: ~S" zb-rule)
  234.     )
  235.       (push (cons lhs zb-rule) *zb-rules*)
  236.       (do ((prods (zb-rule--productions zb-rule) (cdr prods)))
  237.       ((null prods))
  238.     (let* ((production-rhs (car prods))
  239.            (syntax (production-rhs--syntax production-rhs))) 
  240.       (when (member syntax (rest prods)
  241.             :test #'equal :key #'production-rhs--syntax)
  242.         (warn "Multiply defined rhs of rule for ~S: ~S" lhs syntax))
  243.       (when (member "" syntax :test #'equal)
  244.         (warn "Empty keyword ignored in rhs of ~s:~{ ~s~}" lhs syntax)
  245.         (setf syntax
  246.           (setf (production-rhs--syntax production-rhs)
  247.             (delete "" syntax :test #'equal))))
  248.       (expand-Kleene-constituent production-rhs)))
  249.       (do ((prods (zb-rule--productions zb-rule) (cdr prods)))
  250.       ((null prods))
  251.     (let* ((production-rhs (car prods))
  252.            (syntax (production-rhs--syntax production-rhs))
  253.            syntax1)            ; the <NT>.<digit> notation is removed
  254.       ;; remove the  <NT>.<digit> notation from the rhs
  255.       (do ((rhs-tail syntax (cdr rhs-tail))) ((null rhs-tail))
  256.         (let ((constituent (car rhs-tail)))
  257.           (typecase constituent
  258.         (symbol
  259.          (when (and (production-rhs--semantics production-rhs)
  260.                 (member constituent (cdr rhs-tail)))
  261.            (warn "Duplicate constituent in RHS of ~S~% ~S~% Use <NT>.<digit>"
  262.              lhs syntax))
  263.          (let ((cname (constituent-name constituent)))
  264.            (push cname syntax1)
  265.            (pushnew cname non-terminals)))
  266.         (T (push constituent syntax1)))))
  267.       (when do-semantics? (process-semantics production-rhs))
  268.       (process-production lhs (nreverse syntax1))))))
  269.   (let* ((lhs-non-terminals (nreverse (mapcar #'car *zb-rules*)))
  270.      (lexical-categories (mapcar #'(lambda (c)
  271.                      (symbol-name (car c)))
  272.                      *lex-cats*))
  273.      (rhs-non-terminals 
  274.       (set-difference non-terminals
  275.               (union *open-categories* lexical-categories)
  276.               :test #'string-equal :key #'string))
  277.      (undefined-non-terminals (set-difference rhs-non-terminals
  278.                           lhs-non-terminals))
  279.      (unused-non-terminals (set-difference (cdr lhs-non-terminals)
  280.                            ;; the start symbol does not
  281.                            ;; have to occur on any rhs
  282.                            rhs-non-terminals))
  283.      (unused-lex-cats
  284.       (set-difference lexical-categories non-terminals
  285.               :test #'string= :key #'string))
  286.      (overused-lex-cats
  287.       (intersection lhs-non-terminals lexical-categories
  288.             :test #'string= :key #'string)))       
  289.     (when undefined-non-terminals
  290.       (warn "The following non-terminals had no definition:~% ~{~a ~}"
  291.         undefined-non-terminals))
  292.     (when unused-non-terminals
  293.       (warn "The following non-terminals where defined but not used:~% ~{~a ~}"
  294.         unused-non-terminals))
  295.     (when unused-lex-cats
  296.       (warn "The following lexical categories where defined but not used:~% ~{~a ~}"
  297.         unused-lex-cats))
  298.     (when overused-lex-cats
  299.       (warn "The following lexical categories where also defined as non-terminals:~% ~{~a ~}"
  300.         overused-lex-cats))))
  301.  
  302. ;----------------------------------------------------------------------------;
  303. ; expand-Kleene-constituent
  304. ;--------------------------
  305. ; handle Kleene * and +:  adds to *Kleene+-rules*
  306. ;; * case will expand:
  307. ;; (defrule <X>*
  308. ;;  ::= ()
  309. ;;  ::= <x> <X>*-rest)
  310. ;; (defrule <X>*-rest
  311. ;;  ::= ()
  312. ;;  ::= <Sep> <x> <X>*-rest)
  313. ;; in case of default seperator " ":
  314. ;; (defrule <X>*
  315. ;;  ::= ()
  316. ;;  ::= <x> <X>*)
  317. ;; + case will expand:
  318. ;; (defrule <X>+ 
  319. ;;  ::= <x> :build (make-kb-sequence :first <x>)
  320. ;;  ::= <x> <Sep> <x>+ 
  321. ;;      :build (make-kb-sequence :first <x> :rest <x>+))
  322. (defun expand-Kleene-constituent (production-rhs)
  323.   (flet ((new-kb-seq (pairs)
  324.        (let ((slots (mapcar
  325.              #'(lambda (pair)
  326.                  (make-LABEL-VALUE-PAIR
  327.                   :-LABEL (first pair) :-VALUE (second pair)))
  328.              pairs)))
  329.          (make-feat-term :-type 'kb-sequence
  330.                  :-slots slots)))
  331.      (memo (item) (push item *Kleene+-rules*)))
  332.     (dolist (constituent (production-rhs--syntax production-rhs))
  333.       (when (Kleene-p constituent)
  334.     (let* ((Kleene-const (Kleene--constituent constituent))
  335.            (Kleene-Sep (Kleene--Separator constituent))
  336.            (Kleene+ (encode-separator Kleene-const
  337.                       (Kleene*-p constituent)
  338.                       Kleene-Sep)))
  339.       (declare (symbol Kleene+))
  340.       ;; replace the Kleene-expr by a new non-terminal: Kleene+
  341.       (setf (production-rhs--syntax production-rhs)
  342.         (substitute Kleene+ constituent
  343.                 (production-rhs--syntax production-rhs)))
  344.       (let ((semantics (production-rhs--semantics production-rhs)))
  345.         (when (and (feat-term-p semantics)
  346.                (not (default-separator? Kleene-Sep)))
  347.           (feat-term-substitute 
  348.            Kleene+ (decode-kleene-name Kleene+) semantics)))
  349.       ;; (break "constituent: ~S" constituent) 
  350.       (unless (find Kleene+ *Kleene+-rules* :key #'zb-rule--name)
  351.         ;; only if a rule of that name has not been defined yet!
  352.         (let ((KR-sem (new-kb-seq `((first ,Kleene-const)
  353.                     (rest  ,Kleene+)))))
  354.           (if (Kleene*-p constituent) ; * case
  355.           (if (default-separator? Kleene-Sep)
  356.               (memo (make-zb-rule
  357.                  :-name Kleene+
  358.                  :-productions
  359.                  `(,(make-Production-Rhs)
  360.                    ,(make-Production-Rhs
  361.                  :-syntax `(,Kleene-const ,Kleene+)
  362.                  :-semantics KR-sem))))
  363.             (let ((X*-rest (intern
  364.                     (format nil "Rest-~a"
  365.                         (symbol-name Kleene+)))))
  366.               (setq KR-sem
  367.                 (new-kb-seq `((first ,Kleene-const)
  368.                       (rest  ,X*-rest))))
  369.               (memo (make-zb-rule
  370.                  :-name Kleene+
  371.                  :-productions
  372.                  `(,(make-Production-Rhs)
  373.                    ,(make-Production-Rhs
  374.                  :-syntax `(,Kleene-const ,X*-rest)
  375.                  :-semantics KR-sem))))
  376.               (memo (make-zb-rule
  377.                  :-name X*-rest
  378.                  :-productions
  379.                  `(,(make-Production-Rhs)
  380.                    ,(make-Production-Rhs
  381.                  :-syntax
  382.                  `(,Kleene-Sep ,Kleene-const ,X*-rest)
  383.                  :-semantics KR-sem))))))
  384.         (progn
  385.           ;; (break "constituent: ~S" constituent) 
  386.           (memo (make-zb-rule
  387.              :-name Kleene+
  388.              :-productions
  389.              `(,(make-Production-Rhs
  390.                  :-syntax (list Kleene-const)
  391.                  :-semantics (new-kb-seq `((first ,Kleene-const))))
  392.                ,(make-Production-Rhs
  393.                  :-syntax `(,Kleene-const
  394.                     ,@(unless (default-separator? Kleene-Sep)
  395.                           (list Kleene-Sep))
  396.                     ,Kleene+)
  397.                  :-semantics KR-sem)))))))))))
  398.     ;; (format t "~%*Kleene+-rules*: ~{~s ~}" (mapcar #'ZB-RULE--name *Kleene+-rules*))
  399.     ))
  400.  
  401. (defun default-separator? (Kleene-Sep)
  402.   (member Kleene-Sep '(" " "") :test #'string=))
  403.  
  404. (defun encode-separator (name k* Sep)
  405.   ;; k* = true iff Kleene operator is *
  406.   ;; k* = false iff Kleene operator is +
  407.   (intern (if (default-separator? Sep)
  408.           (format nil "~S~:[+~;*~]" name k*)
  409.         (format nil "~S~:[+~;*~]~A~D$"
  410.             name
  411.             k*
  412.             Sep
  413.             (length Sep)))))
  414.  
  415. (defun decode-kleene-name (name)
  416.   (let* ((s (symbol-name name))
  417.      (s-length (length s))
  418.      (n (schar s (- s-length 2)))
  419.      (sep-length (- (char-int n) (char-int #\0))))
  420.     (intern (subseq s 0 (- s-length sep-length 2)))))
  421.  
  422. (defun constituent-name (constituent)
  423.   ;; constituent:symbol
  424.   ;; strip off .<N> from constituent symbol, unless it ends in $
  425.   (let* ((n (symbol-name constituent))
  426.      (last-char-pos (1- (length n))))
  427.     (if (char= (schar n last-char-pos) #\$)
  428.     constituent
  429.       (let ((p (position-if #'(lambda (c) (char= c #\.)) n
  430.                 :from-end t)))
  431.     (if (and p 
  432.          (let ((p+1 (1+ p)))
  433.            (and (= p+1 last-char-pos)
  434.             (digit-char-p (schar n p+1)))))
  435.         (intern (subseq n 0 p) (symbol-package constituent))
  436.       constituent)))))
  437.  
  438. (defun feat-term-substitute (new old ft)
  439.   (dolist (slot (feat-term--slots ft))
  440.     (let ((val (label-value-pair--value slot)))
  441.       (if (eq val old)
  442.       (setf (label-value-pair--value slot) new)
  443.     (when (feat-term-p val)
  444.         (feat-term-substitute new old val))))))
  445.  
  446. (defun parse-defrule (rule &aux name)
  447.   (unless (and (consp rule) 
  448.            (symbolp (car rule))
  449.            (string= (string (car rule)) "DEFRULE")
  450.            (consp (cdr rule))
  451.            (symbolp (setq name (cadr rule))))
  452.     (error "Illegal rule ~S" rule))
  453.   (let ((args (cddr rule)) rhs)
  454.     (flet ((parse-build (&key form type map)
  455.          (cond ((and (not form) type)
  456.             (if (symbolp type)
  457.             (setf form (generate-form type map))
  458.               (error "Symbol expected as value of :type ~S in ~S"
  459.                  type rhs))))
  460.          (multiple-value-bind (ll dummies)
  461.          (make-lambda-list rhs)
  462.            (setq dummies
  463.              (nconc dummies
  464.                 (mapcan #'(lambda (l)
  465.                     (unless (member l dummies)
  466.                         (unless (search-list l form)
  467.                         (list l))))
  468.                     ll)))
  469.            ;; now generate the functions from the actions
  470.            `(lambda ,ll
  471.          ,@(when dummies `((declare (ignore .,dummies))))
  472.          ,form)
  473.            )))
  474.       (let ((R (make-zb-rule :-name name)) action rest)
  475.     (do ((args args rest))
  476.         ((null args)
  477.          (setf (zb-rule--productions r) (nreverse (zb-rule--productions r)))
  478.          R)
  479.       (let ((key (car args))
  480.         (val (cadr args)))
  481.         (setq rest (cddr args))
  482.         (if (eq key ':=)
  483.         (progn
  484.           (setq rhs (if (listp val) val (list val)))
  485.           (if (and (consp rest) (eq (car rest) ':BUILD))
  486.               ;; BUILD clause: construct fn and compile it
  487.               (let ((build-args (cadr rest)))
  488.             (setq action
  489.                   (if (atom build-args)
  490.                   (if (symbolp build-args)
  491.                       build-args
  492.                     (parse-build :FORM build-args))
  493.                 (if (keywordp (car build-args))
  494.                     (apply #'parse-build build-args)
  495.                   (parse-build :FORM build-args))))
  496.             (setq rest (cddr rest)))
  497.             ;; no :BUILD clause, use IDENTITY fn
  498.             (setq action 
  499.               (if (= (length rhs) 1) 'identity 'identity*))))
  500.           (error "Keyword expected in rule ~S at .. ~{~S ~}~% Probably no () around rule's rhs"
  501.              name args))
  502.         (push (make-production-rhs :-syntax rhs
  503.                        :-build-fn action)
  504.           (zb-rule--productions r))))))))
  505.  
  506. (defun cons-avm (Feat-Term)
  507.   (let ((type (Feat-Term--type Feat-Term)))
  508.     (cons
  509.      (intern (concatenate 'string "MAKE-"
  510.               (symbol-name type))
  511.          (symbol-package type))
  512.      (mapcan
  513.       #'(lambda (lvp)
  514.       (declare (type Label-value-pair lvp))
  515.       (let ((slot (Label-value-pair--label lvp))
  516.         (val (Label-value-pair--value lvp)))
  517.         (list (intern (string slot) *keyword-package*)
  518.           (if (Feat-Term-p val)
  519.               (cons-avm val)
  520.             val))))
  521.       (Feat-Term--slots Feat-Term)))))
  522.  
  523. (defun process-semantics (production-rhs)
  524.   (let ((Syntax (production-rhs--syntax production-rhs))
  525.     (Feat-Term (production-rhs--semantics production-rhs)))
  526.     (flet ((msg ()
  527.          (format nil "The Semantics ~S of the rule RHS:~%  ~A~%"
  528.              Feat-Term
  529.              (with-output-to-string (s)
  530.                (print-production-rhs production-rhs s nil)))))
  531.       (flet ((cons-lambda (ft?)
  532.            (multiple-value-bind (ll dummies)
  533.            (make-lambda-list Syntax)
  534.          `(lambda ,ll
  535.            ,@(when dummies `((declare (ignore .,dummies))))
  536.            ,(if ft? (cons-avm Feat-Term) Feat-Term)))))
  537.     (setf (production-rhs--build-fn production-rhs)
  538.           (typecase Feat-Term
  539.         (NULL (if (= 1 (length syntax))
  540.               'identity
  541.             'identity*))
  542.         ((or number string) 
  543.          `(lambda (&rest args) (declare (ignore args))
  544.            ,Feat-Term))
  545.         (symbol
  546.          (if (member Feat-Term Syntax)
  547.              (cons-lambda nil)
  548.            (error "~A is a variable that does not occur in the RHS!"
  549.               (msg))))
  550.         (Feat-Term (cons-lambda t))
  551.         (T (error "~A should be a feature term, number, string or constituent!" (msg)))))))))
  552.  
  553.       
  554. ;----------------------------------------------------------------------------;
  555. ; generate-form
  556. ;--------------
  557. ; 
  558. ; 
  559. (defun generate-form (type map)
  560.   `(,(intern (concatenate 'string "MAKE-" (symbol-name type))
  561.       (symbol-package type))
  562.     ,@(mapcan
  563.        #'(lambda (pair)
  564.        (unless (consp pair)
  565.          (error "Element of :map must be a dotted pair in ~S"
  566.             map))
  567.        (let ((constituent (car pair))
  568.          (slot  (cdr pair)))
  569.          (unless (symbolp constituent)
  570.            (error "Symbol expected in map ~S at ~S"
  571.               map constituent))
  572.          (unless (keywordp slot)
  573.            (error "Keyword expected in map ~S at ~S"
  574.               map slot))
  575.          (list slot constituent)))
  576.        map)))
  577.  
  578. (defun make-lambda-list (constituents)
  579.   (let ((ignore *ignore*) dummies)
  580.     (values (mapcar #'(lambda (constituent)
  581.             (if (symbolp constituent)
  582.                 constituent
  583.               (let ((d (intern (pop ignore))))
  584.                 (push d dummies)
  585.                 d)))
  586.             constituents)
  587.         dummies)))
  588.  
  589. ;; search the list for atom and return T if atom occurs anywhere
  590. ;; this is overly cautious and should be replaced by a tree-walker
  591. ;; but it will only cause some warnings of the compiler.
  592. (defun search-list (atom tree)
  593.   (if (atom tree)
  594.       (eq atom tree)
  595.     (when (consp tree)
  596.     (dolist (n tree)
  597.        (when (search-list atom n) (return t))))))
  598.       
  599.     
  600. #||
  601. (apply #'parse-build '( "(" Formula ")" ) '(:form (progn Formula)))
  602. (apply #'parse-build '(Identifier) '(:type Propositional-variable
  603.                      :map ((Identifier . :-name))))
  604. (apply #'parse-build '(Formula.1 "and" Formula.2)
  605.        '(:type Boolean-And
  606.      :map ((Formula.1 . :-rand1)
  607.            (Formula.2 . :-rand2))))
  608. ||#  
  609.  
  610.  
  611. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  612. ;;                           Top level load function
  613. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  614. ;;; LOAD-GRAMMAR loads a Zebu source grammar and prepares it for 
  615. ;;; compilation
  616. ;;; Internalize a grammar in the lisp syntax described above.
  617. ;;; Set up data structures as described above.
  618. ;;; Every grammar interns the empty string as a grammar symbol
  619. ;;; Generate the hierarchy, if a :domain is specified
  620. ;;; and if *generate-domain* is true.
  621.  
  622. (defun get-grammar-options-key (name)
  623.   (do ((options *grammar-options* (cddr options)))
  624.       ((null options) nil)
  625.     (when (eq (car options) name) (RETURN (cadr options)))))
  626.  
  627. (defun load-grammar (filename &key (verbose T)
  628.                   &aux (g-file (probe-file filename)))
  629.   (unless g-file
  630.     (error "grammar file not found: ~S" filename))
  631.   (format t "~%Reading grammar from ~A~%" filename)
  632.   (initialize-grammar)
  633.   ;; read first form (possibly twice -- in the right package)
  634.   (let ((grammar-stream (open g-file :direction :input)))
  635.     (unwind-protect
  636.      (progn
  637.        (setq *grammar-options*
  638.          (catch 'read-grammar-options
  639.            (check-grammar-options
  640.             (read grammar-stream) g-file t)))
  641.        (unless *grammar-options*
  642.          (close grammar-stream)
  643.          (setq grammar-stream (open g-file :direction :input))
  644.          (setq *grammar-options*
  645.            (catch 'read-grammar-options
  646.              (check-grammar-options
  647.               (read grammar-stream) g-file t))))
  648.        (setq *lex-cats* (get-grammar-options-key ':lex-cats))
  649.        (if (eq *compiler-grammar* *NULL-Grammar*)
  650.            (let ((eof (list nil)))  
  651.          (pre-process-rules
  652.           #'(lambda ()
  653.               (loop (let ((rule (read grammar-stream nil eof)))
  654.                   (if (eq rule eof)
  655.                   (return nil)
  656.                 (if (eq (car rule) 'defstruct)
  657.                     (push rule *domain-structs*)
  658.                   (return (parse-defrule rule)))))))
  659.           nil))
  660.          (let (*preserve-case*
  661.            *Kleene+-rules*
  662.            (ff (file-parser-aux
  663.             grammar-stream #'error t *compiler-grammar*
  664.             verbose)))
  665.            (pre-process-rules
  666.         #'(lambda ()
  667.             (loop
  668.              (let ((f (or (pop ff) (pop *Kleene+-rules*))))
  669.                (if (null f)
  670.                (return nil)
  671.              (if (zb-rule-p f)
  672.                  (return f)
  673.                (push f *domain-types*))))))
  674.         t))))
  675.       (close grammar-stream)))
  676.   (format t "~%~S productions, ~S symbols~%"
  677.       *production-count* *g-symbol-count*)
  678.   (setq *symbol-array* (list->vector (reverse *symbols*)))
  679.   (unless *start-symbol* (error "No start symbol"))
  680.   g-file)
  681.  
  682. ;;;------------------------------------------------------------------------;
  683. ;; dump-domain-file
  684. ;;;------------------------------------------------------------------------;
  685. ;; generate code for domain, printers, and regular expressions
  686. ;; dump it onto the domain-file
  687. ;; it may be the case that none of the above are necessary, in which 
  688. ;; case no domain-file is generated
  689. ;; the domain-file is specified as:
  690. ;;   name: from grammar-option :DOMAIN-FILE
  691. ;;   type: the first element of *load-source-pathname-types*
  692. ;;   directory: same as grammar-file
  693. ;;              if not directory in grammar-file from
  694. ;;                      *default-pathname-defaults*
  695. ;; if such a file exists already, a warning is given and the old file 
  696. ;; is renamed.
  697.  
  698. (defun dump-domain-file (grammar-file verbose)
  699.   (let* ((domain-file 
  700.       (merge-pathnames
  701.        (or (get-grammar-options-key ':DOMAIN-FILE)
  702.            (format nil "~A-domain"
  703.                (get-grammar-options-key ':NAME)))
  704.        (merge-pathnames
  705.         (merge-pathnames (make-pathname
  706.                   :type (first *load-source-pathname-types*))
  707.                  grammar-file)
  708.         *default-pathname-defaults*)))         
  709.      (*print-array* t)        ; bit-vectors of regex code
  710.      *print-level* *print-length* *print-circle*
  711.      written?)
  712.     #-MCL (when (probe-file domain-file)
  713.         (warn "Renaming existing domain file ~a" domain-file))
  714.     (with-open-file (port domain-file
  715.               :if-does-not-exist :create
  716.               :if-exists #-MCL :rename #+MCL :supersede
  717.               :direction :output)
  718.       (format port ";;; This file was generated by Zebu (Version ~a)~%~%(IN-PACKAGE ~S)~%(REQUIRE \"zebu-package\")~%(USE-PACKAGE \"ZEBU\")~%"
  719.           zb:*zebu-version* (package-name *package*))
  720.  
  721.       (when *generate-domain* 
  722.     (format t "~%Generating domain source code onto file: ~a"
  723.         domain-file)
  724.     (setq written? (generate-domain-file domain-file port)))
  725.  
  726.       ;; Write actions onto domain file
  727.       (when verbose
  728.     (format t "~%Writing actions of rules to ~a" domain-file)
  729.     (terpri port))
  730.       (dolist (r *zb-rules*)
  731.     (let ((non-terminal (car r)))
  732.       (when verbose (format t "~%Rule ~S" non-terminal))
  733.       (dolist (production (zb-rule--productions (cdr r)))
  734.         (let ((fn (production-rhs--build-fn production)))
  735.           (when (consp fn)
  736.         (let ((fn-name (gentemp (symbol-name non-terminal))))
  737.           (when verbose (format t " Action: ~S" fn-name))
  738.           (setf (production-rhs--build-fn production) fn-name)
  739.           (pprint `(defun ,fn-name . ,(cdr fn)) port)
  740.           (terpri port)
  741.           (setq written? t)))))))
  742.       (terpri port)
  743.       ;; for lexical categories: compile the rx-token parsers!
  744.       (when *lex-cats*
  745.     (pprint '(eval-when (compile)
  746.           (unless (member "zebu-regex" *modules* :test #'equal)
  747.             (WARN "Load the Zebu Compiler!")))
  748.         port)
  749.     (pprint '(declaim (special *REGEX-GROUPS* *REGEX-GROUPINGS*))
  750.         port)
  751.     (dolist (lex-cat *lex-cats*)
  752.       (pprint (def-regex-parser (car lex-cat) (cadr lex-cat))
  753.           port)
  754.       (terpri port))
  755.     (setq written? t))
  756.       (when written?
  757.     (nconc *grammar-options* (list ':DOMAIN-FILE
  758.                        (namestring domain-file)))
  759.     domain-file))))
  760.     
  761. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  762. ;;                           End of zebu-loadgram.lisp
  763. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  764.